home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / bignum.t < prev    next >
Text File  |  1988-05-02  |  11KB  |  316 lines
  1. (herald bignum
  2.   (env tsys (osys fixnum) bignum))
  3.  
  4. ;;; (c) Copyright 1983, 1984 Yale University
  5.  
  6. ;;; To do:
  7. ;;;   destructive routines
  8. ;;;   rewrite print-bignum & associates (format nil ... etc)
  9. ;;;   pool bignums
  10. ;;;   bignum templates, positve & negative ?
  11. ;;;   pack densely - use hardware multiply, etc
  12.  
  13. ;;; WARNING
  14. ;;;  Parts of this depend on (>= *bits-per-hyperdigit* *bits-per-fixnum*) => T.
  15.  
  16. ;;; Constants:
  17.  
  18. (define-constant *bits-per-hyperdigit* 30)
  19.  
  20. (define-constant *max-hyperdigit* -1)
  21.  
  22. (define-constant *half-max-hyperdigit*
  23.   (fx- (fixnum-ashl 1 (fx- *bits-per-hyperdigit* 1)) 1))
  24.  
  25. (lset *bignums-print-nicely?* nil)
  26.  
  27. (define-handler bignum
  28.   (object nil
  29.     ((extended-number-type self) %%bignum-number-type)
  30.     ((print self port)
  31.      (if *bignums-print-nicely?*
  32.          (print-bignum self port)
  33.          (print-bignum-guts self port)))))
  34.  
  35. (define (print-bignum-guts self port)
  36.   (format port "{Bignum ~D ~A["
  37.           (object-hash self) 
  38.           (if (bignum-positive? self) "+" "-"))
  39.   (format port "~X" (bignum-digit self 0))
  40.   (do ((i 1 (fx+ i 1)))
  41.       ((fx>= i (bignum-length self)))
  42.     (format port "~_~X" (bignum-digit self i)))
  43.   (format port "]}"))
  44.  
  45. ;;; Comparison:
  46.  
  47. (define-integrable (bignum-magnitude-less? u v)
  48.   (fx< (bignum-compare-magnitudes u v) 0))
  49.  
  50. ;;; Returns a fixnum whose sign is the same as (- u v).
  51.  
  52. (define (bignum-compare u v)
  53.   (let ((u-sign (bignum-sign u)))
  54.     (cond ((fxn= u-sign (bignum-sign v)) u-sign)
  55.           ((fx> u-sign 0) (bignum-compare-magnitudes u v))
  56.           (else           (bignum-compare-magnitudes v u)))))
  57.  
  58. (define-integrable (bignum-less? u v)
  59.   (fx< (bignum-compare u v) 0))
  60.  
  61. (define-integrable (bignum-equal? u v)
  62.   (fx= (bignum-compare u v) 0))
  63.  
  64. ;;; Sign negotiation and normalization:
  65.  
  66. ;;; The BIGNUM-FOO routines negotiate a sign for the result, then
  67. ;;; dispatch to the appropriate FOO-MAGNITUDES routine.  The result
  68. ;;; is then normalized.
  69.  
  70. (define (bignum-add u v)
  71.   (let ((u-sign (bignum-sign u))
  72.         (v-sign (bignum-sign v)))
  73.     (normalize-integer
  74.      (cond ((fx= u-sign v-sign)
  75.             (set-bignum-sign! (add-magnitudes u v) u-sign))
  76.            ((bignum-magnitude-less? u v)
  77.             (set-bignum-sign! (subtract-magnitudes v u) v-sign))
  78.            (else
  79.             (set-bignum-sign! (subtract-magnitudes u v) u-sign))))))
  80.  
  81. (define (bignum-subtract u v)
  82.   (let ((u-sign (bignum-sign u))
  83.         (v-sign (bignum-sign v)))
  84.     (normalize-integer
  85.      (cond ((fxn= u-sign v-sign)
  86.             (set-bignum-sign! (add-magnitudes u v) u-sign))
  87.            ((bignum-magnitude-less? v u)
  88.             (set-bignum-sign! (subtract-magnitudes u v) u-sign))
  89.            (else
  90.             (set-bignum-sign! (subtract-magnitudes v u)
  91.                              (fixnum-negate u-sign)))))))
  92.  
  93. (define-integrable (bignum-multiply-sign u v)
  94.   (if (fx= (bignum-sign u) (bignum-sign v)) 1 -1))
  95.  
  96. (define (bignum-multiply u v)
  97.   (normalize-integer
  98.    (set-bignum-sign! (multiply-magnitudes u v) (bignum-multiply-sign u v))))
  99.  
  100. ;;; Used only by BIGNUM-DIVIDE, BIGNUM-REMAINDER, and B-F-DIV2
  101.  
  102. (define (bignum-div2 u v)
  103.   (let ((m (bignum-compare-magnitudes u v)))
  104.     (cond ((fx= m 0)
  105.            (return (bignum-multiply-sign u v) 0))
  106.           ((fx< m 0)
  107.            (return 0 u))
  108.           (else
  109.            (receive (q r)
  110.                     (div2-magnitudes u v)
  111.              (return (normalize-integer
  112.                       (set-bignum-sign! q (bignum-multiply-sign u v)))
  113.                      (normalize-integer
  114.                       (set-bignum-sign! r (bignum-sign u)))))))))
  115.  
  116. (define (bignum-divide u v)    (receive (q r) (bignum-div2 u v) q))
  117. (define (bignum-remainder u v) (receive (q r) (bignum-div2 u v) r))
  118.  
  119. (define (b-f-add u v)      (bignum-add u (fixnum->bignum v)))
  120. (define (b-f-subtract u v) (bignum-subtract u (fixnum->bignum v)))
  121.  
  122. (define (b-f-divide u v)    (receive (q r) (b-f-div2 u v) q))
  123. (define (b-f-remainder u v) (receive (q r) (b-f-div2 u v) r))
  124.  
  125. (define (fixnum-ashl-bignum num amount)
  126.   (bignum-ashl (fixnum->bignum num) amount))   ; Fix later
  127.  
  128. (define (bignum-ashr-fixnum src amount)
  129.   (normalize-integer (bignum-ashr src amount)))
  130.  
  131. ;;; Total randomness: negate, odd?, howlong.
  132.  
  133. (define (bignum-negate num)
  134.   (let ((new (copy-bignum num)))
  135.     (bignum-negate! new)
  136.     (normalize-integer new)))
  137.  
  138. (define (bignum-odd? num)
  139.   (fixnum-odd? (bignum-digit num 0)))
  140.  
  141. (define (bignum-howlong num)
  142.   (let ((last (fx- (bignum-length num) 1)))
  143.     (fx+ (fixnum-howlong (bignum-digit num last))
  144.          (fx* last *bits-per-hyperdigit*))))
  145.  
  146. ;;; MAGN is a fixnum interpreted as an unsigned  integer that is 
  147. ;;; *bits-per-fixnum* long.  EXTRA-BIT? is a handy N+1st bit for those
  148. ;;; times that you have (+ *bits-per-fixnum* 1) bits of magnitude.
  149.  
  150. (define (sign&magnitude->bignum sign extra-bit? magn)
  151.   (let ((num (create-bignum (if extra-bit? 2 1))))
  152.     (set (bignum-digit num 0) magn)
  153.     (if extra-bit? (set (bignum-digit num 1) 1))
  154.     (set-bignum-sign! num sign)
  155.     num))
  156.  
  157. ;;; Normalization:
  158.  
  159. ;;; Convert an integer to normal form.  That is, if it is a bignum within
  160. ;;; the fixnum range, convert it to a fixnum.
  161.  
  162. (define (normalize-integer n)
  163.   (cond ((fixnum? n) n)
  164.         ((if (bignum-positive? n)
  165.              (bignum-less? most-positive-fixnum-as-bignum n)
  166.              (bignum-less? n most-negative-fixnum-as-bignum))
  167.          n)
  168.         (else (bignum->fixnum n))))
  169.  
  170. (define-constant most-positive-fixnum-as-bignum
  171.   (sign&magnitude->bignum  1 nil most-positive-fixnum))
  172.  
  173. (define-constant most-negative-fixnum-as-bignum
  174.   (sign&magnitude->bignum -1 nil most-negative-fixnum))
  175.  
  176.  
  177. ;;; Coercion routines:
  178.  
  179. (define (fixnum->bignum fx)
  180.   (cond ((fx= fx most-negative-fixnum) most-negative-fixnum-as-bignum)
  181.         (else (sign&magnitude->bignum (if (fx< fx 0) -1 1) 
  182.                       nil
  183.                       (fixnum-abs fx)))))
  184.  
  185. (define (bignum->fixnum bn)
  186.   (cond ((bignum-equal? most-negative-fixnum-as-bignum bn) most-negative-fixnum)
  187.         ((bignum-positive? bn) (bignum-digit bn 0))
  188.         (else
  189.          (fx- 0 (bignum-digit bn 0)))))
  190.  
  191. (define (bignum->flonum b)
  192.   (error "integer to float conversion not yet implemented~%  (~S ~S)"
  193.          '->float b))
  194.  
  195. ;;; Input and output:
  196. ;++ This can be speeded up if necessary.
  197.  
  198. (define (print-bignum num port)
  199.   (let ((new-num (normalize-integer num)))
  200.     (cond ((neq? num new-num)
  201.            (format port "#{Unnormalized-bignum~_~S}"
  202.                    new-num))
  203.           (else
  204.            (let ((buffer (bignum->buffer num)))
  205.              (cond ((not (bignum-positive? num)) (writec port negative-sign-char)))
  206.              (do ((i (fx- (buffer-length buffer) 1) (fx- i 1)))
  207.                  ((not (char= (buffer-elt buffer i) #\0))
  208.                   (do ((i i (fx- i 1)))
  209.                       ((fx< i 0) (release-buffer buffer))
  210.                     (writec port (buffer-elt buffer i))))))))))
  211.  
  212. ;;; Convert a bignum to a sequence of characters.
  213. ;;; Characters are generated in reverse order by successive divisions.
  214.  
  215. (define (bignum->buffer num)
  216.   (let* ((radix (rt-radix *print-table*))
  217.          (k (\#chars-in-bit-field radix *bits-per-hyperdigit*))
  218.          (radix^k (fixnum-expt radix k))
  219.          (buffer (get-buffer)))
  220.     (iterate loop ((num num))
  221.       (receive (q r)
  222.                (b-f-div2-unnormalized num radix^k)
  223.         (output-bignum-digit (fixnum-abs r) k buffer radix)
  224.         (cond ((fx> (bignum-length q) 1)
  225.                (loop q))
  226.               (else
  227.                (iterate loop ((n (bignum-digit q 0)))
  228.                  (if (fx= n 0)
  229.                      buffer
  230.                      (loop (output-bignum-digit n k buffer radix))))))))))
  231.  
  232. ;;; Generate k digits of output.  Returns the k+1'th digit.
  233.  
  234. (define (output-bignum-digit digit k buffer radix)
  235.   (iterate loop ((n digit)
  236.                  (i k))
  237.     (cond ((fx> i 0)
  238.            (receive (q r)
  239.                     (%digit-divide 0 n radix)
  240.              (vm-write-char buffer (digit->char r radix))
  241.              (loop q (fx- i 1))))
  242.           (else n))))
  243.  
  244. ;;; Number of characters in RADIX that can surely fit in FIELD-SIZE bits.
  245. ;;; Make this more accurate.  How does BIGNUM-STRINGIFY work and did
  246. ;;; I screw it up by changing this routine?
  247.  
  248. (define (\#chars-in-bit-field radix field-size)
  249.   (fx/ field-size (fixnum-howlong radix)))
  250.  
  251. ;;; Convert string to fixnum or bignum, as appropriate.
  252.  
  253. (define (string->integer string radix)
  254.   (cond ((char= (char string) negative-sign-char)
  255.          (string->integer-aux string 1 t radix))
  256.         ((char= (char string) positive-sign-char)
  257.          (string->integer-aux string 1 nil radix))
  258.         (else
  259.          (string->integer-aux string 0 nil radix))))
  260.  
  261. ;;;  We grab a bunch of digits at a whack, convert them to fixnum, and
  262. ;;;  do multiplications just with them.  
  263. ;;; grabsize:  number of digits we can grab (whack size)
  264. ;;; shift:     radix of grabsize considered as a hyperdigit
  265. ;;; leftovers: number of digits that don't fit into an even number of grabs -
  266. ;;;            convert these first
  267.  
  268. ;;; Fast enough?  Clean enough?
  269. ;;; Hack sign inside loop rather than after so that we read most-negative-fixnum
  270. ;;; as a fixnum and not a bignum.
  271. ;;; Note that any compiler worth its salt will integrate the definitions
  272. ;;; of my+ and my*.
  273.  
  274. (define (string->integer-aux string start neg? radix)
  275.   (let ((length (string-length string))
  276.         (grabsize (\#chars-in-bit-field radix *u-bits-per-fixnum*))
  277.         (my* (lambda (x y) (cond ((fixnum? x) (fixnum-multiply-carefully x y))
  278.                                  (else (b-f-multiply x y)))))
  279.         (my+ (lambda (x y) (cond ((fixnum? x) (fixnum-add-carefully x y))
  280.                                  (else (b-f-add x y))))))
  281.     (let ((shift (fixnum-expt radix grabsize))
  282.           (leftovers (fixnum-remainder (fx- length start) grabsize)))
  283.       (let ((sum (string->fixnum string start leftovers radix)))
  284.         (do ((sum (if neg? (fixnum-negate sum) sum)
  285.                   (my+ (my* sum shift) 
  286.                        (let ((x (string->fixnum string strpos grabsize radix)))
  287.                          (if neg? (fixnum-negate x) x))))
  288.              (strpos (fx+ start leftovers)
  289.                      (fx+ strpos grabsize)))
  290.             ((fx>= strpos length) sum))))))
  291.  
  292.  
  293. ;;; This belongs elsewhere
  294.  
  295. (define (string->fixnum string start count radix)
  296.   (let ((limit (fx+ start count)))
  297.     (do ((i start (fx+ i 1))
  298.          (sum 0 (fx+ (fx* sum radix) (%char->digit (nthchar string i) radix))))
  299.         ((fx>= i limit) sum))))
  300.  
  301.  
  302. ;;; Debugging utility:
  303.  
  304. ;(define-syntax (bignum-pig x)
  305. ;  `(',*bignum-pig (lambda () ,x)))
  306.  
  307. (define (*bignum-pig x)
  308.   (let ((b1 *bignum-cons-counter*)
  309.         (b2 *bignum-cons-size-counter*))
  310.     (let ((val (x))
  311.           (a1 *bignum-cons-counter*)
  312.           (a2 *bignum-cons-size-counter*))
  313.       `(count = ,(fx- a1 b1) total = ,(fx- a2 b2) value = ,val))))
  314.  
  315. (set *bignums-print-nicely?* t)
  316.